
(* INPUT-OUTPUT PRIMITIVES *)

FUNCTION CANTSTRETCH(VAR F: FIB): BOOLEAN;
  LABEL 1;
  VAR LINX: DIRRANGE; FOUND: BOOLEAN; LAVAILBLK: INTEGER; LDIR: DIRP;
BEGIN CANTSTRETCH := TRUE;
  WITH F,FHEADER DO
    IF LENGTH(DTID) > 0 THEN
      BEGIN (*IN A DIRECTORY FOR SURE*)
	IF FUNIT <> VOLSEARCH(FVID,FALSE,LDIR) THEN
	  BEGIN SYSCOM^.IORSLT := ILOSTUNIT; GOTO 1 END;
	FOUND := FALSE; LINX := 1;
	WHILE (LINX <= LDIR^[0].DNUMFILES) AND NOT FOUND DO
	  BEGIN
	    FOUND := (LDIR^[LINX].DFIRSTBLK = DFIRSTBLK) AND
		     (LDIR^[LINX].DLASTBLK = DLASTBLK);
	    LINX := LINX+1
	  END;
	IF NOT FOUND THEN
	  BEGIN SYSCOM^.IORSLT := ILOSTFILE; GOTO 1 END;
	IF LINX > LDIR^[0].DNUMFILES THEN
	  LAVAILBLK := LDIR^[0].DEOVBLK
	ELSE LAVAILBLK := LDIR^[LINX].DFIRSTBLK;
	IF (DLASTBLK < LAVAILBLK) OR (DLASTBYTE < FBLKSIZE) THEN
	  BEGIN
	    WITH LDIR^[LINX-1] DO
	      BEGIN
		DLASTBLK := LAVAILBLK; DLASTBYTE := FBLKSIZE;
		WRITEDIR(FUNIT,LDIR);
		IF IORESULT <> ORD(INOERROR) THEN GOTO 1
	      END;
	    FEOF := FALSE; FEOLN := FALSE; FGOTACHAR := FALSE;
	    DLASTBLK := LAVAILBLK; DLASTBYTE := FBLKSIZE;
	    DACCESS.YEAR := 100; CANTSTRETCH := FALSE
	  END
      END;
  IF FALSE THEN
1:  BEGIN F.FEOF := TRUE; F.FEOLN := TRUE END
END (*CANTSTRETCH*) ;

PROCEDURE FRESET(*VAR F: FIB*);
  VAR BIGGER: BOOLEAN;
BEGIN SYSCOM^.IORSLT := INOERROR;
  WITH F DO
    IF FISOPEN THEN
      BEGIN FGOTACHAR := FALSE; FEOLN := FALSE; FEOF := FALSE;
	IF FISBLKD THEN
	  BEGIN BIGGER := FNXTBLK > FMAXBLK;
	    IF BIGGER THEN FMAXBLK := FNXTBLK;
	    IF FSOFTBUF THEN
	      BEGIN
		IF BIGGER THEN FMAXBYTE := FNXTBYTE
		ELSE
		  IF FNXTBLK = FMAXBLK THEN
		    IF FNXTBYTE > FMAXBYTE THEN
			FMAXBYTE := FNXTBYTE;
		IF FBUFCHNGD THEN
		  BEGIN FBUFCHNGD := FALSE; FMODIFIED := TRUE;
		    UNITWRITE(FUNIT,FBUFFER,FBLKSIZE,
				    FHEADER.DFIRSTBLK+FNXTBLK-1)
		  END;
		FNXTBYTE := FBLKSIZE
	      END;
	    FNXTBLK := 0;
	    IF FSOFTBUF THEN
	      IF (FRECSIZE = 1) AND (FHEADER.DFKIND = TEXTFILE) THEN
		FNXTBLK := 2
	  END
      END
END (*FRESET*) ;

FUNCTION FBLOCKIO(*VAR F: FIB; VAR A: WINDOW;
		   NBLOCKS,RBLOCK: INTEGER; DOREAD: BOOLEAN*);
  LABEL 1;
BEGIN FBLOCKIO := 0; SYSCOM^.IORSLT := INOERROR;
  WITH F DO
    IF FISOPEN AND (NBLOCKS >= 0) THEN
      IF FISBLKD THEN
	WITH FHEADER DO
	  BEGIN
	    IF RBLOCK < 0 THEN RBLOCK := FNXTBLK;
	    RBLOCK := DFIRSTBLK+RBLOCK;
	    IF RBLOCK+NBLOCKS > DLASTBLK THEN
	      IF DOREAD THEN NBLOCKS := DLASTBLK-RBLOCK
	      ELSE
		IF CANTSTRETCH(F) THEN NBLOCKS := DLASTBLK-RBLOCK
		ELSE
		  IF RBLOCK+NBLOCKS > DLASTBLK THEN
		    NBLOCKS := DLASTBLK-RBLOCK;
	    FEOF := RBLOCK >= DLASTBLK;
	    IF NOT FEOF THEN
	      BEGIN
		IF DOREAD THEN
		  UNITREAD(FUNIT,A,NBLOCKS*FBLKSIZE,RBLOCK)
		ELSE
		  BEGIN FMODIFIED := TRUE;
		    UNITWRITE(FUNIT,A,NBLOCKS*FBLKSIZE,RBLOCK)
		  END;
		IF IORESULT <> ORD(INOERROR) THEN GOTO 1;
		FBLOCKIO := NBLOCKS;
		RBLOCK := RBLOCK+NBLOCKS;
		FEOF := RBLOCK = DLASTBLK;
		FNXTBLK := RBLOCK-DFIRSTBLK;
		FMAXBYTE := FBLKSIZE;
		IF FNXTBLK > FMAXBLK THEN FMAXBLK := FNXTBLK
	      END
	  END
      ELSE
	BEGIN FBLOCKIO := NBLOCKS;
	  IF DOREAD THEN
	    UNITREAD(FUNIT,A,NBLOCKS*FBLKSIZE,RBLOCK)
	  ELSE
	    UNITWRITE(FUNIT,A,NBLOCKS*FBLKSIZE,RBLOCK);
	  IF IORESULT = ORD(INOERROR) THEN
	    IF DOREAD THEN
	      BEGIN RBLOCK := NBLOCKS*FBLKSIZE;
		RBLOCK := RBLOCK+SCAN(-RBLOCK,<>CHR(0),A[RBLOCK-1]);
		RBLOCK := (RBLOCK+FBLKSIZE-1) DIV FBLKSIZE;
		FBLOCKIO := RBLOCK;
		FEOF := RBLOCK < NBLOCKS
	      END
	    ELSE
	  ELSE FBLOCKIO := 0
	END
    ELSE SYSCOM^.IORSLT := INOTOPEN;
1:
END (*FBLOCKIO*) ;

PROCEDURE FGET(*VAR F: FIB*);
  LABEL 1;
  VAR LEFTOGET,WININX,LEFTINBUF,AMOUNT: INTEGER;
      DONE: BOOLEAN;
BEGIN SYSCOM^.IORSLT := INOERROR;
  WITH F DO
    IF FISOPEN THEN
      BEGIN
	IF FSOFTBUF THEN
	  WITH FHEADER DO
	    BEGIN
	      LEFTOGET := FRECSIZE; WININX := 0;
	      REPEAT
		IF FNXTBLK = FMAXBLK THEN
		  IF FNXTBYTE+LEFTOGET > FMAXBYTE THEN GOTO 1
		  ELSE LEFTINBUF := DLASTBYTE-FNXTBYTE
		ELSE LEFTINBUF := FBLKSIZE-FNXTBYTE;
		AMOUNT := LEFTOGET;
		IF AMOUNT > LEFTINBUF THEN AMOUNT := LEFTINBUF;
		IF AMOUNT > 0 THEN
		  BEGIN
		    MOVELEFT(FBUFFER[FNXTBYTE],FWINDOW^[WININX],AMOUNT);
		    FNXTBYTE := FNXTBYTE+AMOUNT;
		    WININX := WININX+AMOUNT;
		    LEFTOGET := LEFTOGET-AMOUNT
		  END;
		DONE := LEFTOGET = 0;
		IF NOT DONE THEN
		  BEGIN FNXTBYTE := 0; (*GET NEXT BLOCK*)
		    IF FBUFCHNGD THEN
		      BEGIN FBUFCHNGD := FALSE; FMODIFIED := TRUE;
			UNITWRITE(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK+FNXTBLK-1)
		      END;
		    IF IORESULT <> ORD(INOERROR) THEN GOTO 1;
		    UNITREAD(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK+FNXTBLK);
		    FNXTBLK := FNXTBLK+1;
		    IF IORESULT <> ORD(INOERROR) THEN GOTO 1
		  END
	      UNTIL DONE
	    END
	ELSE
	  BEGIN
	    UNITREAD(FUNIT,FWINDOW^,FRECSIZE);
	    IF IORESULT <> ORD(INOERROR) THEN GOTO 1
	  END;
	IF FRECSIZE = 1 THEN (*FILE OF CHAR*)
	  BEGIN FEOLN := FALSE; FGOTACHAR := TRUE;
	    IF FWINDOW^[0] = CHR(EOL) THEN
	      BEGIN FWINDOW^[0] := ' '; FEOLN := TRUE END;
	    IF FWINDOW^[0] = CHR(0) THEN
	      BEGIN (*EOF HANDLING*)
		IF FSOFTBUF AND (FHEADER.DFKIND = TEXTFILE) THEN
		  BEGIN (*END OF 2 BLOCK PAGE*)
		    IF ODD(FNXTBLK) THEN FNXTBLK := FNXTBLK+1;
		    FNXTBYTE := FBLKSIZE; FGET(F)
		  END
		ELSE
		  BEGIN FWINDOW^[0] := ' '; GOTO 1 END
	      END
	  END
      END
    ELSE SYSCOM^.IORSLT := INOTOPEN;
  IF FALSE THEN
1:  BEGIN F.FEOF := TRUE; F.FEOLN := TRUE END
END (*FGET*) ;

PROCEDURE FPUT(*VAR F: FIB*);
  LABEL 1;
  VAR LEFTOPUT,WININX,LEFTINBUF,AMOUNT: INTEGER;
      DONE: BOOLEAN;
BEGIN SYSCOM^.IORSLT := INOERROR;
  WITH F DO
    IF FISOPEN THEN
      BEGIN
	IF FSOFTBUF THEN
	  WITH FHEADER DO
	    BEGIN
	      LEFTOPUT := FRECSIZE; WININX := 0;
	      REPEAT
		IF DFIRSTBLK+FNXTBLK = DLASTBLK THEN
		  IF FNXTBYTE+LEFTOPUT > DLASTBYTE THEN
		    IF CANTSTRETCH(F) THEN GOTO 1
		    ELSE LEFTINBUF := FBLKSIZE-FNXTBYTE
		  ELSE LEFTINBUF := DLASTBYTE-FNXTBYTE
		ELSE LEFTINBUF := FBLKSIZE-FNXTBYTE;
		AMOUNT := LEFTOPUT;
		IF AMOUNT > LEFTINBUF THEN AMOUNT := LEFTINBUF;
		IF AMOUNT > 0 THEN
		  BEGIN FBUFCHNGD := TRUE;
		    MOVELEFT(FWINDOW^[WININX],FBUFFER[FNXTBYTE],AMOUNT);
		    FNXTBYTE := FNXTBYTE+AMOUNT;
		    WININX := WININX+AMOUNT;
		    LEFTOPUT := LEFTOPUT-AMOUNT
		  END;
		DONE := LEFTOPUT = 0;
		IF NOT DONE THEN
		  BEGIN FNXTBYTE := 0; (*WRITE BUFFER...MAYBE GET NEXT*)
		    IF FBUFCHNGD THEN
		      BEGIN FBUFCHNGD := FALSE; FMODIFIED := TRUE;
			UNITWRITE(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK+FNXTBLK-1)
		      END;
		    IF IORESULT <> ORD(INOERROR) THEN GOTO 1;
		    IF FNXTBLK < FMAXBLK THEN
		      UNITREAD(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK+FNXTBLK)
		    ELSE
		      IF FRECSIZE = 1 THEN
			FILLCHAR(FBUFFER,FBLKSIZE,CHR(0));
		    FNXTBLK := FNXTBLK+1;
		    IF IORESULT <> ORD(INOERROR) THEN GOTO 1
		  END
	      UNTIL DONE;
	      IF FRECSIZE = 1 THEN
		IF FWINDOW^[0] = CHR(EOL) THEN
		  IF DFKIND = TEXTFILE THEN
		    IF (FNXTBYTE >= FBLKSIZE-80) AND NOT ODD(FNXTBLK) THEN
		      BEGIN
			FNXTBYTE := FBLKSIZE-1;
			FWINDOW^[0] := CHR(0);
			FPUT(F)
		      END

	    END
	ELSE
	  BEGIN
	    UNITWRITE(FUNIT,FWINDOW^,FRECSIZE);
	    IF IORESULT <> ORD(INOERROR) THEN GOTO 1
	  END
      END
    ELSE SYSCOM^.IORSLT := INOTOPEN;
  IF FALSE THEN
1:  BEGIN F.FEOF := TRUE; F.FEOLN := TRUE END
END (*FPUT*) ;

FUNCTION FEOF(*VAR F: FIB*);
BEGIN FEOF := F.FEOF END;

(* TEXT FILE INTRINSICS *)

FUNCTION FEOLN(*VAR F: FIB*);
BEGIN FEOLN := F.FEOLN END;

PROCEDURE FWRITELN(*VAR F: FIB*);
BEGIN
  F.FWINDOW^[0] := CHR(EOL); FPUT(F)
END (*FWRITELN*) ;

PROCEDURE FWRITECHAR(*VAR F: FIB; CH: CHAR; RLENG: INTEGER*);
  LABEL  1;
BEGIN
  WITH F DO
    IF FISOPEN THEN
      IF FSOFTBUF THEN
	BEGIN
	  WHILE RLENG > 1 DO
	    BEGIN FWINDOW^[0] := ' '; FPUT(F);
	      RLENG := RLENG-1
	    END;
	  FWINDOW^[0] := CH; FPUT(F)
	END
      ELSE
	BEGIN
	  WHILE RLENG > 1 DO
	    BEGIN FWINDOW^[0] := ' ';
	      UNITWRITE(FUNIT,FWINDOW^,1);
	      RLENG := RLENG-1
	    END;
	  FWINDOW^[0] := CH;
	  UNITWRITE(FUNIT,FWINDOW^,1)
	END
    ELSE SYSCOM^.IORSLT := INOTOPEN;
1:
END (*FWRITECHAR*) ;

PROCEDURE FWRITEINT(*VAR F: FIB; I,RLENG: INTEGER*);
  VAR POT,COL: INTEGER; CH: CHAR;
      SUPPRESSING: BOOLEAN; S: STRING[10];
BEGIN COL := 1; SUPPRESSING := TRUE;
  IF I < 0 THEN
    BEGIN I := ABS(I); S[1] := '-'; COL := 2;
      IF I < 0 THEN I := 0
    END;
  FOR POT := 4 DOWNTO 0 DO
    BEGIN CH := CHR(I DIV IPOT[POT] + ORD('0'));
      IF (CH = '0') AND (POT > 0) AND SUPPRESSING THEN
      ELSE (*FORMAT THE CHAR*)
	BEGIN SUPPRESSING := FALSE;
	  S[COL] := CH; COL := COL+1;
	  IF CH <> '0' THEN I := I MOD IPOT[POT]
	END
    END;
  S[0] := CHR(COL-1);
  FWRITESTRING(F,S,RLENG)
END (*FWRITEINT*) ;

PROCEDURE FWRITEREAL(*VAR F: FIB; X: REAL; W,D: INTEGER*);
  VAR I,J,TRUNCX,SINX: INTEGER;
      CH: CHAR; S: STRING[20];

  PROCEDURE PUTCH(CH: CHAR);
  BEGIN
    S[SINX] := CH; SINX := SINX+1
  END (*PUTCH*) ;

BEGIN
    S[0] := CHR(20); SINX := 1; PUTCH(' ');
    IF (W < 0) OR (D < 0) OR (D > 6) THEN
      BEGIN D := 0; W := 0 END;
    IF X < 0 THEN
      BEGIN X := ABS(X); S[1] := '-' END;
    IF X = 0 THEN I := 0
    ELSE I := TRUNC(LOG(X));
    IF I > 0 THEN X := X/PWROFTEN(I)
    ELSE
      IF I < 0 THEN X := X*PWROFTEN(ABS(I));
    IF X = 0 THEN
      BEGIN CH := '0'; TRUNCX := 0 END
    ELSE
      REPEAT TRUNCX := TRUNC(X);
	CH := CHR(TRUNCX+ORD('0'));
	IF TRUNCX = 0 THEN
	  BEGIN I := I-1; X := X*10 END
      UNTIL TRUNCX <> 0;
    PUTCH(CH); PUTCH('.');
    X := (X-TRUNCX)*10; J := 0;
    REPEAT TRUNCX := TRUNC(X);
      PUTCH(CHR(TRUNCX+ORD('0')));
      X := (X-TRUNCX)*10;
      J := J+1
    UNTIL J = 6;
    SINX := 3;
    IF (I > 0) AND (I < 6) THEN
      IF (6-I) >= D THEN
	BEGIN
	  MOVELEFT(S[SINX+1],S[SINX],I);
	  SINX := SINX+I; S[SINX] := '.';
	  I := 0
	END;
    IF D = 0 THEN
      BEGIN D := 9;
	WHILE S[D] = '0' DO D := D-1;
	D := D-SINX;
	IF D = 0 THEN D := 1
      END;
    SINX := SINX+D+1;
    IF SINX <= 9 THEN
      IF S[SINX] >= '5' THEN
	BEGIN
	  FOR J := SINX-1 DOWNTO 2 DO
	    IF S[J] <> '.' THEN
	      BEGIN
		S[J] := SUCC(S[J]);
		IF S[J] > '9' THEN S[J] := '0'
		ELSE J := 0
	      END;
	  IF J > 0 THEN
	    BEGIN SINX := SINX+1;
	      MOVERIGHT(S[2],S[3],12);
	      S[2] := '1'
	    END
	END;
    IF I <> 0 THEN
      BEGIN PUTCH('E');
	IF I < 0 THEN
	  BEGIN PUTCH('-'); I := ABS(I) END;
	IF I > 9 THEN
	  BEGIN PUTCH(CHR(I DIV 10 + ORD('0')));
	    I := I MOD 10
	  END;
	PUTCH(CHR(I + ORD('0')))
      END;
    S[0] := CHR(SINX-1);
    FWRITESTRING(F,S,W)
END (*FWRITEREAL*) ;

PROCEDURE FWRITESTRING(*VAR F: FIB; VAR S: STRING; RLENG: INTEGER*);
  VAR SINX: INTEGER;
BEGIN
  WITH F DO
    IF FISOPEN THEN
      BEGIN
	IF RLENG <= 0 THEN RLENG := LENGTH(S);
	IF RLENG > LENGTH(S) THEN
	  BEGIN FWRITECHAR(F,' ',RLENG-LENGTH(S)); RLENG := LENGTH(S) END;
	IF FSOFTBUF THEN
	  BEGIN SINX := 1;
	    WHILE (SINX <= RLENG) AND NOT FEOF DO
	      BEGIN FWINDOW^[0] := S[SINX]; FPUT(F); SINX := SINX+1 END
	  END
	ELSE
	  UNITWRITE(FUNIT,S[1],RLENG)
      END
    ELSE SYSCOM^.IORSLT := INOTOPEN
END (*FWRITESTRING*) ;

PROCEDURE FWRITEBYTES(*VAR F: FIB; VAR A: WINDOW; RLENG,ALENG: INTEGER*);
  VAR AINX: INTEGER;
BEGIN
  WITH F DO
    IF FISOPEN THEN
      BEGIN
	IF RLENG > ALENG THEN
	  BEGIN FWRITECHAR(F,' ',RLENG-ALENG); RLENG := ALENG END;
	IF FSOFTBUF THEN
	  BEGIN AINX := 0;
	    WHILE (AINX < RLENG) AND NOT FEOF DO
	      BEGIN FWINDOW^[0] := A[AINX]; FPUT(F); AINX := AINX+1 END
	  END
	ELSE
	  UNITWRITE(FUNIT,A,RLENG)
      END
    ELSE SYSCOM^.IORSLT := INOTOPEN
END (*FWRITEBYTES*) ;

PROCEDURE FREADLN(*VAR F: FIB*);
BEGIN
  WHILE NOT F.FEOLN DO FGET(F);
  F.FGOTACHAR := FALSE; F.FEOLN := FALSE
END (*FREADLN*) ;

PROCEDURE FREADCHAR(*VAR F: FIB; VAR CH: CHAR*);
BEGIN
  WITH F DO
    IF FISOPEN THEN
      BEGIN SYSCOM^.IORSLT := INOERROR;
	IF NOT FGOTACHAR THEN FGET(F);
	CH := FWINDOW^[0];
	FGOTACHAR := FALSE
      END
    ELSE SYSCOM^.IORSLT := INOTOPEN
END (*FREADCHAR*) ;

PROCEDURE FREADINT(*VAR F: FIB; VAR I: INTEGER*);
  LABEL 1;
  VAR CH: CHAR; NEG,IVALID: BOOLEAN;
BEGIN
  WITH F DO
    IF FISOPEN THEN
      BEGIN I := 0; NEG := FALSE; IVALID := FALSE;
	IF NOT FGOTACHAR THEN FGET(F);
	WHILE (FWINDOW^[0] = ' ') AND NOT FEOF DO FGET(F);
	IF FEOF THEN GOTO 1;
	CH := FWINDOW^[0];
	IF (CH = '+') OR (CH = '-') THEN
	  BEGIN NEG := CH = '-'; FGET(F); CH := FWINDOW^[0] END;
	WHILE (CH IN ['0'..'9']) AND NOT FEOF DO
	  BEGIN IVALID := TRUE;
	    I := I*10 + ORD(CH) - ORD('0');
	    FGET(F); CH := FWINDOW^[0]
	  END;
	IF IVALID OR FEOF THEN
	  IF NEG THEN I := -I ELSE (*NADA*)
	ELSE SYSCOM^.IORSLT := IBADFORMAT
      END
    ELSE SYSCOM^.IORSLT := INOTOPEN;
1:
END (*FREADINT*) ;

PROCEDURE FREADREAL(*VAR F: FIB; VAR X: REAL*);
  LABEL 1;
  VAR CH: CHAR; NEG,XVALID: BOOLEAN; IPOT: INTEGER;
      NUMBERS: SET OF '0'..'9';
BEGIN
  WITH F DO
    IF FISOPEN THEN
      BEGIN X := 0; NEG := FALSE; XVALID := FALSE;
	NUMBERS := ['0'..'9'];
	IF NOT FGOTACHAR THEN FGET(F);
	WHILE (FWINDOW^[0] = ' ') AND NOT FEOF DO FGET(F);
	IF FEOF THEN GOTO 1;
	CH := FWINDOW^[0];
	IF (CH = '+') OR (CH = '-') THEN
	  BEGIN NEG := CH = '-'; FGET(F); CH := FWINDOW^[0] END;
	WHILE (CH IN NUMBERS) AND NOT FEOF DO
	  BEGIN XVALID := TRUE;
	    X := X*10 + (ORD(CH)-ORD('0'));
	    FGET(F); CH := FWINDOW^[0]
	  END;
	IF FEOF THEN GOTO 1;
	IPOT := -1;
	IF CH = '.' THEN
	  BEGIN IPOT := 0;
	    REPEAT FGET(F); CH := FWINDOW^[0];
	      IF CH IN NUMBERS THEN
		BEGIN XVALID := TRUE; IPOT := IPOT + 1;
		  X := X + (ORD(CH)-ORD('0'))/PWROFTEN(IPOT)
		END
	    UNTIL FEOF OR NOT (CH IN NUMBERS);
	    IF FEOF THEN GOTO 1
	  END;
	IF ((CH = 'e') OR (CH = 'E')) AND (XVALID OR (IPOT < 0)) THEN
	  BEGIN FGOTACHAR := FALSE; FREADINT(F,IPOT);
	    IF FEOF THEN GOTO 1;
	    IF NOT XVALID THEN X := 1; XVALID := TRUE;
	    IF IPOT < 0 THEN X := X/PWROFTEN(ABS(IPOT))
	    ELSE X := X*PWROFTEN(IPOT)
	  END;
	IF XVALID THEN
	  IF NEG THEN X := -X
	  ELSE
	ELSE SYSCOM^.IORSLT := IBADFORMAT
      END
    ELSE SYSCOM^.IORSLT := INOTOPEN;
1:
END (*FREADREAL*) ;

PROCEDURE FREADSTRING(*VAR F: FIB; VAR S: STRING; SLENG: INTEGER*);
  VAR SINX: INTEGER; CH: CHAR;
BEGIN
  WITH F DO
    IF FISOPEN THEN
      BEGIN SINX := 1;
	IF FEOLN THEN FREADLN(F);
	S[0] := CHR(SLENG); (*NO INV INDEX*)
	WHILE (SINX <= SLENG) AND NOT (FEOLN OR FEOF) DO
	  BEGIN
	    IF NOT FGOTACHAR THEN FGET(F);
	    IF NOT FEOLN THEN
	      BEGIN
		CH := FWINDOW^[0]; FGOTACHAR := FALSE;
		IF FUNIT = 1 THEN
		  IF CHECKDEL(CH,SINX) THEN
		  ELSE
		    BEGIN S[SINX] := CH; SINX := SINX + 1 END
		ELSE
		  BEGIN S[SINX] := CH; SINX := SINX + 1 END
	      END
	  END;
	S[0] := CHR(SINX - 1);
	WHILE NOT FEOLN DO FGET(F)
      END
    ELSE SYSCOM^.IORSLT := INOTOPEN
END (*FREADSTRING*) ;

(* STRING VARIABLE INTRINSICS *)

PROCEDURE SCONCAT(*VAR SRC,DEST: STRING; DESTLENG: INTEGER*);
BEGIN
  IF LENGTH(SRC)+LENGTH(DEST) <= DESTLENG THEN
    BEGIN
      MOVELEFT(SRC[1],DEST[LENGTH(DEST)+1],LENGTH(SRC));
      DEST[0] := CHR(LENGTH(SRC)+LENGTH(DEST))
    END
END (*SCONCAT*) ;

PROCEDURE SINSERT(*VAR SRC,DEST: STRING; DESTLENG,INSINX: INTEGER*);
  VAR ONRIGHT: INTEGER;
BEGIN
  IF (INSINX > 0) AND (LENGTH(SRC) > 0) AND
      (LENGTH(SRC)+LENGTH(DEST) <= DESTLENG) THEN
    BEGIN
      ONRIGHT := LENGTH(DEST)-INSINX+1;
      IF ONRIGHT > 0 THEN
	BEGIN
	  MOVERIGHT(DEST[INSINX],DEST[INSINX+LENGTH(SRC)],ONRIGHT);
	  ONRIGHT := 0
	END;
      IF ONRIGHT = 0 THEN
	BEGIN
	  MOVELEFT(SRC[1],DEST[INSINX],LENGTH(SRC));
	  DEST[0] := CHR(LENGTH(DEST)+LENGTH(SRC))
	END
    END
END (*SINSERT*) ;

PROCEDURE SCOPY(*VAR SRC,DEST: STRING; SRCINX,COPYLENG: INTEGER*);
BEGIN DEST := '';
  IF (SRCINX > 0) AND (COPYLENG > 0) AND
      (SRCINX+COPYLENG-1 <= LENGTH(SRC)) THEN
    BEGIN
      MOVELEFT(SRC[SRCINX],DEST[1],COPYLENG);
      DEST[0] := CHR(COPYLENG)
    END
END (*SCOPY*) ;

PROCEDURE SDELETE(*VAR DEST: STRING; DELINX,DELLENG: INTEGER*);
  VAR ONRIGHT: INTEGER;
BEGIN
  IF (DELINX > 0) AND (DELLENG > 0) THEN
    BEGIN
      ONRIGHT := LENGTH(DEST)-DELINX-DELLENG+1;
      IF ONRIGHT = 0 THEN DEST[0] := CHR(DELINX-1)
      ELSE
	IF ONRIGHT > 0 THEN
	  BEGIN
	    MOVELEFT(DEST[DELINX+DELLENG],DEST[DELINX],ONRIGHT);
	    DEST[0] := CHR(LENGTH(DEST)-DELLENG)
	  END
    END
END (*SDELETE*) ;

FUNCTION SPOS(*VAR TARGET,SRC: STRING*);
  LABEL 1;
  VAR I,LASTI: INTEGER; FIRSTCH: CHAR; TEMP: STRING;
BEGIN SPOS := 0;
  IF LENGTH(TARGET) > 0 THEN
    BEGIN FIRSTCH := TARGET[1];
      LASTI := LENGTH(SRC)-LENGTH(TARGET)+1;
      I := 1; TEMP[0] := TARGET[0];
      WHILE I <= LASTI DO
	BEGIN
	  IF SRC[I] = FIRSTCH THEN
	    BEGIN
	      MOVELEFT(SRC[I],TEMP[1],LENGTH(TARGET));
	      IF TEMP = TARGET THEN
		BEGIN SPOS := I; GOTO 1 END
	    END;
	  I := I+1
	END
    END;
1:
END (*SPOS*) ;

(*MAIN STUFF OF SYSTEM*)

PROCEDURE COMPILE;
  LABEL 1;
  VAR LTITLE: STRING[25];
BEGIN
  WITH USERINFO DO
    IF NOT GOTSYM THEN
      BEGIN WRITELN(OUTPUT);
	WRITE(OUTPUT,'No workfile')
      END
    ELSE
      BEGIN
	LTITLE := CONCAT(SYMVID,':',SYMTID);
	FOPEN(SYMFIBP^,LTITLE,TRUE,NIL);
	IF IORESULT <> ORD(INOERROR) THEN
	  BEGIN WRITELN(OUTPUT);
	    WRITE(OUTPUT,'Lost workfile!');
	    GOTSYM := FALSE; GOTO 1
	  END;
	LTITLE := '*SYSTEM.WRK.CODE';
	FOPEN(CODEFIBP^,LTITLE,FALSE,NIL);
	ERRNUM := 0; ERRBLK := 0; ERRSYM := 0;
	WRITELN(OUTPUT,'Compiling...');
	COMPILER(USERINFO);
	RELEASE(EMPTYHEAP);
	FCLOSE(SYMFIBP^,CNORMAL);
	IF SYSCOM^.MISCINFO.HAS8510A THEN UNITCLEAR(3);
	IF ERRNUM > 0 THEN
	  BEGIN
	    FCLOSE(CODEFIBP^,CPURGE);
	    GOTCODE := FALSE;
	    IF STUPID THEN EDITOR;
	    ERRNUM := 0
	  END
	ELSE
	  BEGIN
	    CODEVID := CODEFIBP^.FVID;
	    CODETID := CODEFIBP^.FHEADER.DTID;
	    FCLOSE(CODEFIBP^,CLOCK);
	    GOTCODE := TRUE
	  END
      END;
1:
END (*COMPILE*) ;

PROCEDURE EXECUTE(*RUNWORKFILE: BOOLEAN*);
  LABEL 1;
  VAR LSEG: SEGRANGE; LTITLE: STRING[25];
      LSEGTABLE: ARRAY [SEGRANGE] OF SEGDESC;
BEGIN
  IF RUNWORKFILE THEN
    BEGIN WRITELN(OUTPUT);
      LTITLE := CONCAT(USERINFO.CODEVID,':',USERINFO.CODETID)
    END
  ELSE
    BEGIN
      PL := 'Execute? ';
      IF NOT SYSCOM^.MISCINFO.SLOWTERM THEN
	INSERT(' what file',PL,8);
      PROMPT; READLN(INPUT,LTITLE);
      IF LENGTH(LTITLE) = 0 THEN GOTO 1;
      IF LTITLE[LENGTH(LTITLE)] = '.' THEN
	DELETE(LTITLE,LENGTH(LTITLE),1)
      ELSE
	LTITLE := CONCAT(LTITLE,'.CODE')
    END;
  FOPEN(USERINFO.CODEFIBP^,LTITLE,TRUE,NIL);
  IF IORESULT <> ORD(INOERROR) THEN
    BEGIN
      IF RUNWORKFILE THEN
	BEGIN USERINFO.GOTCODE := FALSE;
	  WRITE(OUTPUT,'Lost workfile!')
	END
      ELSE
	IF IORESULT = ORD(IBADTITLE) THEN
	  WRITE(OUTPUT,'Illegal title')
	ELSE
	  WRITE(OUTPUT,'Can''t find file');
      GOTO 1
    END;
  IF USERINFO.CODEFIBP^.FHEADER.DFKIND <> CODEFILE THEN
    WRITE(OUTPUT,'Must be a code file')
  ELSE
    WITH SYSCOM^,USERINFO DO
      BEGIN
	UNITREAD(CODEFIBP^.FUNIT,LSEGTABLE,(MAXSEG+1)*4,
			CODEFIBP^.FHEADER.DFIRSTBLK);
	IF IORESULT <> ORD(INOERROR) THEN 
	  BEGIN
	    IF RUNWORKFILE THEN WRITELN(OUTPUT);
	    WRITE(OUTPUT,'Bad block # 0'); GOTO 1
	  END;
	FOR LSEG := 1 TO MAXSEG DO
	  IF (LSEG = 1) OR (LSEG >= 10) THEN
	    WITH SEGTABLE[LSEG],LSEGTABLE[LSEG] DO
	      BEGIN CODEUNIT := CODEFIBP^.FUNIT;
		CODEDESC.CODELENG := CODELENG;
		CODEDESC.DISKADDR := DISKADDR + CODEFIBP^.FHEADER.DFIRSTBLK
	      END;
	FRESET(INPUTFIB^); FRESET(OUTPUTFIB^); FRESET(SYSTERM^);
	WRITELN(OUTPUT,'Running...');
	USERPROGRAM(INPUTFIB^,OUTPUTFIB^);
	IF UNITBUSY(1) OR UNITBUSY(2) THEN UNITCLEAR(1);
	FRESET(INPUTFIB^); FRESET(OUTPUTFIB^); FRESET(SYSTERM^)
      END;
1: FCLOSE(USERINFO.CODEFIBP^,CNORMAL)
END (*EXECUTE*) ;

PROCEDURE COMMAND;
  VAR CH: CHAR; BADCOMMAND: BOOLEAN;
BEGIN BADCOMMAND := FALSE;
  REPEAT
    RELEASE(EMPTYHEAP);
    PL :=
'Command: E(dit, R(un, F(ile, C(ompile, X(ecute, D(ebug, I(nit, H(alt';
    PROMPT; CH := GETCHAR(BADCOMMAND); CLEARSCREEN;
    BADCOMMAND := NOT (CH IN ['E','D','R','F','C','X','U','I','H']);
    CASE CH OF
      'E':  EDITOR;
  'D','R':  BEGIN
	      IF NOT USERINFO.GOTCODE THEN COMPILE;
	      IF USERINFO.GOTCODE THEN
		BEGIN CLEARSCREEN;
		  IF CH = 'R' THEN EXECUTE(TRUE)
		  ELSE DEBUGGER
		END
	    END;
      'F':  FILEHANDLER;
      'C':  COMPILE;
      'X':  EXECUTE(FALSE);
      'U':  BEGIN
	      FRESET(INPUTFIB^); FRESET(OUTPUTFIB^); FRESET(SYSTERM^);
	      USERPROGRAM(INPUTFIB^,OUTPUTFIB^); UNITCLEAR(1);
	      FRESET(INPUTFIB^); FRESET(OUTPUTFIB^); FRESET(SYSTERM^)
	    END;
      'I':  INITIALIZE;
      'H':  EMPTYHEAP := NIL
    END
  UNTIL CH = 'H'
END (*COMMAND*) ;

BEGIN (*UCSD PASCAL SYSTEM*)
  EMPTYHEAP := NIL;
  INITIALIZE;
  REPEAT
    COMMAND;
    IF EMPTYHEAP <> NIL THEN
      INITIALIZE
  UNTIL EMPTYHEAP = NIL;
  CLEARSCREEN;
  PL := 'Open for business...'; PROMPT
END (*PASCALSYSTEM*) .

(*$I XOP:GLOBALS.TEXT *)
(*$I XOP:SYSTEM.A.TEXT *)
(*$I XOP:SYSTEM.B.TEXT *)
(*$I XOP:GLOBALS.TEXT *)
(*$I XOP:SYSTEM.A.TEXT *)
(*$I XOP:SYSTEM.B.TEXT *)
